home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / unm68kernel.t < prev    next >
Text File  |  1988-02-05  |  22KB  |  632 lines
  1. (herald m68kernel (env tsys))
  2.  
  3. ;;; note that A1 must not be destroyed and nil-reg is in AN
  4. ;;; return is in TP
  5.  
  6. (define (m68-big-bang) 
  7.   (lap (big_bang icall-bad-proc
  8.         icall-wrong-nargs handle-stack-base
  9.         handle-undefined-effect
  10.         really-gc pc-code-vector  heap-overflow-error
  11.         call-fault-handler cont-wrong-nargs)
  12.  
  13.     (move .l  nil-reg (d@nil -3))            ; (cdr '()) = '()
  14.     (move .l  nil-reg (d@nil 1))             ; (car '()) = '()
  15.  
  16.     (move .l  P (d@nil slink/kernel))        ; save kernel pointer
  17.     (lea (label %undefined-effect) A3)
  18.     (move .l A3       (d@nil  slink/undefined-effect ))
  19.     (lea (label %make-extend) A3)
  20.     (move .l A3       (d@nil  slink/make-extend ))
  21.     (lea (label %make-pair) A3)
  22.     (move .l A3       (d@nil  slink/make-pair ))
  23.     (lea (label %nary-setup) A3)
  24.     (move .l A3       (d@nil  slink/nary-setup ))
  25.     (lea (label %set) A3)
  26.     (move .l A3       (d@nil  slink/set ))
  27.     (lea (label %icall) A3)
  28.     (move .l A3 (d@nil  slink/icall ))
  29.     (lea (label %cont-wrong-nargs) A3)
  30.     (move .l A3 (d@nil  slink/cont-wrong-nargs ))
  31.  
  32.     (lea (label %kernel-begin) A3)
  33.     (move .l A3 (d@nil slink/kernel-begin))
  34.     (lea (label %kernel-end) A3)
  35.     (move .l A3 (d@nil slink/kernel-end))
  36.  
  37.  
  38.     ;; initialize root process, stored in outer space?  
  39.     ;; zero  out extra registers
  40.  
  41.     (move .l ($ temp-block-size) S0)
  42. initialize-loop     
  43.     (clr .l (@-r sp))  
  44.     (sub .l ($ 4) S0)
  45.     (tst .l S0)
  46.     (j> initialize-loop)
  47.     (move .l SP TASK)                                ; load task reg
  48.     (add  .l ($ (fx+ %%task-header-offset 4)) SP)    ; allocate task block
  49.     (move .l ($ header/task) (@-r SP))               ; task header
  50.     (move .l SP A3)
  51.     (add  .l ($ 2) A3)
  52.     (move .l A3 (d@nil slink/root-process))         ; ptr to root and
  53.     (move .l A3 (d@nil slink/current-task))         ; current process
  54.  
  55.     ;; initialize stack
  56.     (pea  (d@r A3 0))                                ; task block
  57.     (move .l nil-reg (@-r SP))                       ; no parent
  58.     (clr  .l (@-r SP))                               ; active, no current sz
  59.     (move .l ($ (fixnum-ashl %%stack-size 2)) (@-r SP))    ; total stack size
  60.     (move .l ($ #xBADBAD) (@-r SP))                  ; distinguished value
  61.     (pea (label stack-base-template))                ; stack base
  62.  
  63.     ;; initialize root process
  64. ;++  (move .l SP A3)
  65. ;++  (add  .l ($ 2) A3)
  66. ;++  (move .l A3 (d@r TASK task/stack))       ; set stack in root-process
  67. ;++ what to do, task/stack is a fixnum not an extend as it should be!
  68.     (move .l SP (d@r TASK task/stack))       ; set stack in root-process
  69.     (clr  .l (d@r TASK task/extra-pointer))
  70.     (clr  .l (d@r TASK task/extra-scratch))
  71.     (move .l nil-reg (d@r TASK task/dynamic-state))
  72.     ;; initialize area,area-frontier and area-limit
  73.     (move .l nil-reg (d@r TASK task/doing-gc?))
  74.     (clr .l (d@r TASK task/foreign-call-cont))
  75.     (clr .l (d@r TASK task/critical-count))
  76.     (move .l nil-reg (d@r TASK task/k-list))
  77.     (move .l nil-reg (d@r TASK task/gc-weak-set-list))
  78.     (move .l nil-reg (d@r TASK task/gc-weak-alist-list))
  79.     (move .l nil-reg (d@r TASK task/gc-weak-table-list))
  80.     (move .l nil-reg (d@nil slink/snapper-freelist))
  81.     (move .l nil-reg (d@nil slink/pair-freelist))
  82.     (move .l (d@static P (static 'big_bang)) P)
  83.     (jmp (@r TP))
  84.  
  85.  
  86. %make-pair
  87.     ;; return pair in AN
  88.     (bset ($ 7) (d@r TASK task/critical-count))
  89.     (move .l (d@r TASK task/area-frontier) AN)
  90.     (add .l ($ 8) AN)
  91.     (cmp .l (d@r TASK task/area-limit) AN)
  92.     (j> %make-pair-heap-overflow)
  93. %make-pair-continue
  94.     (move .l AN (d@r TASK task/area-frontier))
  95.     (sub .l ($ (fx- 8 tag/pair)) AN)             
  96.     (clr .l (d@r AN -3))
  97.     (clr .l (d@r AN 1))
  98.     (and .b ($ #x7f) (d@r TASK task/critical-count))
  99.     (jn= %deferred-interrupts)
  100.     (rts)
  101.                    
  102. %make-pair-heap-overflow
  103.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  104.     (jsr (label %heap-overflow))
  105.     (move .l (d@r TASK task/area-frontier) AN)
  106.     (add .l ($ 8) AN)
  107.     (cmp .l (d@r TASK task/area-limit) AN)
  108.     (j> %horrible-heap-overflow)
  109.     (bset ($ 7) (d@r TASK task/critical-count))
  110.     (move .l nil-reg (d@r TASK task/doing-gc?))
  111.     (jbr %make-pair-continue)
  112.  
  113. %make-extend
  114.     ;; receive descriptor in An, size in S1, return extend in AN
  115.     (bset ($ 7) (d@r TASK task/critical-count))
  116.     (move .l (d@r TASK task/area-frontier) S2) ; get area-frontier
  117.     (add .l ($ 4) S1)
  118.     (add .l S2 S1)                          ; one for the descriptor
  119.     (cmp .l (d@r TASK task/area-limit) S1)
  120.     (j> %make-extend-heap-overflow)
  121. %make-extend-continue
  122.     (move .l S1 (d@r TASK task/area-frontier)) ; S1 is end, S2 is begin
  123.     (exg AN S2)                                ; AN is template
  124.     (move .l S2 (@r+ AN))                      ; store template
  125.     (cmp .l S1 AN)
  126.     (j= copy-done)
  127.     (move .l AN S2)                            ; save extend
  128. extend-loop
  129.     (clr .l (@r+ AN))
  130.     (cmp .l S1 AN)
  131.     (j< extend-loop)
  132.     (move .l S2 AN)
  133. copy-done
  134.     (sub .l ($ 2) AN)
  135.     (and .b ($ #x7f) (d@r TASK task/critical-count))
  136.     (jn= %deferred-interrupts)
  137.     (rts)
  138.                      
  139. %make-extend-heap-overflow
  140.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  141.     (sub .l S2 S1)
  142.     (jsr (label %heap-overflow))
  143.     (move .l (d@r TASK task/area-frontier) S2) ; get area-frontier
  144.     (add .l S2 S1)                          
  145.     (cmp .l (d@r TASK task/area-limit) S1)
  146.     (j> %horrible-heap-overflow)
  147.     (bset ($ 7) (d@r TASK task/critical-count))
  148.     (move .l nil-reg (d@r TASK task/doing-gc?))
  149.     (jbr %make-extend-continue)
  150.  
  151.  
  152. %heap-overflow   
  153.     (movem .l '(d0 d1 d2 d3 d4 d5) (@-r SP))                 ; save scratch registers
  154.     (move .l ($ temp-block-size) S0)
  155. save-loop                                  ; save temps
  156.     (move .l (index (d@r TASK -4) S0) (@-r SP))
  157.     (sub .l ($ 4) S0)
  158.     (j>= save-loop)
  159.     (movem .l '(a0 a1 a2 a3 a4 a5) (@-r SP))
  160.     (move .l (d@r SP (* (+ *no-of-registers* 3) 4)) A1)   ; one for TP 2 return
  161.     (pea (label pc-check-return))
  162.     (move .l nil-reg P)
  163.     (move .l (d@r P slink/kernel) P)
  164.     (move .l (d@static P (static 'pc-code-vector)) P)
  165.     (move .l (d@r P -2) TP)
  166.     (jmp (@r TP))                                ; call pc-code-vector
  167.     
  168. %icall                     
  169.   (move .w P S0)
  170.   (and .b ($ 3) S0)
  171.   (cmp .b ($ tag/extend) S0)                     ; check proc is extend
  172.   (jn= %icall-bad-proc)
  173.   (move .l (d@r P -2) TP)                         ; fetch template
  174.   (move .w TP S0)
  175.   (and .b ($ 3) S0)                 ; check proc is extend
  176.   (cmp .b ($ tag/extend) S0)
  177.   (jn= %icall-bad-proc)
  178.   (move .l  (d@r TP -2) S0)       ; check template is valid (high bit set)
  179.   (j>= %icall-bad-proc)
  180.   (cmp .b (d@r TP template/nargs) NARGS)         ; check number of args
  181.   (j= %icall-ok)
  182.   (j< %icall-wrong-nargs)
  183.   (btst ($ 30) S0)                            ; check nary bit
  184.   (j= %icall-wrong-nargs)
  185. %icall-ok
  186.   (jmp (@r TP))
  187.  
  188. %icall-bad-proc
  189.   (move .l a1 (d@r TASK task/t0))
  190.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  191.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  192.   (clr .l s0)
  193.   (jsr (label %nary-setup))
  194.   (move .l an a2)
  195.   (move .l p a1)
  196.   (move .l (d@nil slink/kernel) P)
  197.   (move .l (d@static P (static 'icall-bad-proc)) P)
  198.   (move .l (d@r P -2) TP)
  199.   (jmp  (@r TP))
  200.  
  201. %icall-wrong-nargs
  202.   (move .l a1 (d@r TASK task/t0))
  203.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  204.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  205.   (clr .l s0)
  206.   (jsr (label %nary-setup))
  207.   (move .l an a2)
  208.   (move .l p a1)
  209.   (move .l (d@nil slink/kernel) P)
  210.   (move .l (d@static P (static 'icall-wrong-nargs)) P)
  211.   (move .l (d@r P -2) TP)
  212.   (jmp  (@r TP))
  213.  
  214.  
  215. %deferred-interrupts
  216.     (movem .l '(d0 d1 d2 d3 d4 d5) (@-r SP))
  217.     (move .l ($ (fx+ temp-block-size 4)) S2)
  218. %int-save-loop                              ; save temps and extra p and s
  219.     (move .l (index (d@r TASK -8) S2) (@-r SP))
  220.     (sub .l ($ 4) S2)
  221.     (j>= %int-save-loop)
  222.     (movem .l '(a0 a1 a2 a3 a4 a5) (@-r SP))
  223.     (clr .l (@-r SP))               ; pc
  224.     (move .l (d@r SP (* (+ *pointer-temps* *scratch-temps* 15) 4)) (@-r SP))           
  225.     (clr .l (@-r SP))               ; no pointers on top
  226.     (move .l ($ (+ (fixnum-ashl (+ *pointer-temps* *scratch-temps* 17) 8)
  227.                    header/fault-frame))
  228.              (@-r SP))
  229.     (pea (label %int-return))
  230.     (move .l (d@nil slink/kernel) P)
  231.     (move .l (d@static P (static 'call-fault-handler)) P)
  232.     (move .l (d@r P -2) TP)                      
  233.     (jmp (@r TP))
  234.  
  235.  
  236. %kernel-begin
  237.  
  238. %cont-wrong-nargs
  239.   (neg .l nargs)
  240.   (move .l a1 (d@r TASK task/t0))
  241.   (move .l a2 (d@r TASK (fx+ task/t0 4)))
  242.   (move .l a3 (d@r TASK (fx+ task/t0 8)))
  243.   (clr .l s0)
  244.   (jsr (label %nary-setup))
  245.   (move .l an a2)
  246.   (lea (d@r sp 2) a1)
  247.   (move .l (d@nil slink/kernel) P)
  248.   (move .l (d@static P (static 'cont-wrong-nargs)) P)
  249.   (move .l (d@r P -2) TP)
  250.   (jmp  (@r TP))
  251.                 
  252. %post-gc-nary-setup
  253.   (move .l ($ -1) S1)
  254.   (jbr %real-nary-setup)                   
  255.   
  256. %nary-setup   
  257.   (clr .l S1)       
  258. %real-nary-setup                                ; not just after GC
  259.   (asl .l ($ 2) S0)                                 ; required args in S0
  260.   (sub .l ($ 2) NARGS)         
  261.   (asl .l ($ 2) NARGS)                                 ; m68 index mode
  262.   (move .l nil-reg AN)
  263.   (move .l P (d@r TASK task/extra-pointer))
  264.   (bset ($ 7) (d@r TASK task/critical-count))
  265.   (jmp (label %nary-test))
  266. %nary-loop
  267.   (move .l AN P)                               ; accumulate in P
  268.   (move .l (d@r TASK task/area-frontier) AN)
  269.   (add .l ($ 8) AN)
  270.   (cmp .l (d@r TASK task/area-limit) AN)
  271.   (j> %nary-make-pair-heap-overflow)
  272. %nary-make-pair-continue                        ; lose, lose
  273.   (move .l AN (d@r TASK task/area-frontier))
  274.   (sub .l ($ (fx- 8 tag/pair)) AN)             
  275.   (clr .l (d@r AN -3))
  276.   (clr .l (d@r AN 1))
  277.   (move .l P (d@r AN -3))                      ; set cdr
  278.   (move .l (index (@r TASK) NARGS) (d@r AN 1)) ; set car
  279.   (sub .l ($ 4) NARGS)
  280. %nary-test
  281.   (cmp .l NARGS S0)
  282.   (j<= %nary-loop)
  283.   (tst .l S1)
  284.   (jn= nary-clear-extras)
  285.   (move .l (d@r TASK task/extra-pointer) P)                            
  286.   (and .b ($ #x7f) (d@r TASK task/critical-count))
  287.   (jn= %deferred-interrupts)
  288.   (rts)     
  289. nary-clear-extras
  290.   (cmp .l ($ 12) S0)
  291.   (j>= foo45)
  292.   (move .l ($ 12) S0)
  293. foo45
  294.   (clr .l (index (@r TASK) S0))
  295.   (add .l ($ 4) S0)
  296.   (cmp .l ($ temp-block-size) S0)
  297.   (j< foo45)
  298.   (lea (label %nary-setup) P)
  299.   (move .l P (d@nil slink/nary-setup))
  300.   (move .l (d@r TASK task/extra-pointer) P)                            
  301.   (and .b ($ #x7f) (d@r TASK task/critical-count))
  302.   (jn= %deferred-interrupts)
  303.   (rts)     
  304.  
  305.   
  306.   
  307.  
  308. %nary-make-pair-heap-overflow
  309.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  310.     (jsr (label %heap-overflow))
  311.     (move .l (d@r TASK task/area-frontier) AN)
  312.     (add .l ($ 8) AN)
  313.     (cmp .l (d@r TASK task/area-limit) AN)
  314.     (j> %horrible-heap-overflow)
  315.     (bset ($ 7) (d@r TASK task/critical-count))
  316.     (move .l nil-reg (d@r TASK task/doing-gc?))
  317.     (jbr %nary-make-pair-continue)
  318.  
  319. %set                                        ; a location is (unit  . index)
  320.    ;;  vcell in extra-pointer
  321.    (bset ($ 7) (d@r TASK task/critical-count))
  322.    (movem .l '(a0 a1 a2 a3 a4) (@-r sp))
  323.    (move .l (d@r TASK task/extra-pointer) a3)
  324.    (move .l (d@r A3 6) A1)                  ; get locations
  325.    (move .l (d@r A1 2) A1)                  ; get the vector in A1
  326.    (move .l (d@r A1 -2) SCRATCH)
  327.    (asr .l ($ 8) SCRATCH)                        ; length in S0
  328.    (asl .l ($ 2) SCRATCH)
  329.    (jbr %set-test)
  330. %set-loop
  331.    (move .l (d@nil slink/snapper-freelist) an)
  332.    (cmp .l an nil-reg)
  333.    (j= cons-snapper)
  334.    (move .l (d@r an 1) p)
  335.    (move .l (d@r an -3) (d@nil slink/snapper-freelist))
  336.    (move .l (d@nil slink/pair-freelist) (d@r an -3))
  337.    (move .l an (d@nil slink/pair-freelist))
  338. %real-top
  339.    (move .l (index (d@r A1 -6) SCRATCH) A2)      ; get unit
  340.    (move .l (index (d@r A1 -2) SCRATCH) AN)      ; get index
  341.    (move .l (d@r a3 2) (d@r p 2))
  342.    (move .l a2 (d@r p 6))
  343.    (move .l an (d@r p 10))
  344.    (move .l p (index (d@r A2 2) AN))
  345.    (sub .l ($ 8) SCRATCH)
  346. %set-test
  347.    (tst .l SCRATCH)
  348.    (jn= %set-loop)
  349.    (movem .l (@r+ sp) '(a0 a1 a2 a3 a4))
  350.    (and .b ($ #x7f) (d@r TASK task/critical-count))
  351.    (jn= %deferred-interrupts)
  352.    (rts)
  353. cons-snapper
  354.    (move .l (d@r TASK task/area-frontier) AN)
  355.    (add .l ($ 16) AN)
  356.    (cmp .l (d@r TASK task/area-limit) AN)
  357.    (j> %set-heap-overflow)
  358. %set-continue                        ; lose, lose
  359.    (move .l AN (d@r TASK task/area-frontier))
  360.    (lea (d@r an -14) p)
  361.    (lea (label link-snapper) a2)
  362.    (move .l a2 (d@r p -2))
  363.    (jbr %real-top)
  364. %set-heap-overflow
  365.     (move .l ($ header/true) (d@r TASK task/doing-gc?))
  366.     (move .l ($ (+ (fixnum-ashl 5 16) (fixnum-ashl 1 8) header/vframe )) (@-r sp))
  367.     (move .l (d@r sp 24) (@-r sp))
  368.     (jsr (label %heap-overflow))
  369.     (move .l (@r sp) (d@r sp 28))
  370.     (add .w ($ 8) sp)
  371.     (move .l (d@r TASK task/area-frontier) AN)
  372.     (add .l ($ 16) AN)
  373.     (cmp .l (d@r TASK task/area-limit) AN)
  374.     (j> %horrible-heap-overflow)
  375.     (bset ($ 7) (d@r TASK task/critical-count))
  376.     (move .l nil-reg (d@r TASK task/doing-gc?))
  377.     (jbr %set-continue)
  378.  
  379. %kernel-end
  380.  
  381. %horrible-heap-overflow
  382.   (add .w ($ 4) SP)
  383.   (bclr ($ 7) (d@r TASK task/critical-count))
  384.   (move .l nil-reg (d@r TASK task/doing-gc?))
  385.   (move .l (d@nil slink/kernel) P)
  386.   (move .l (d@static P (static 'heap-overflow-error)) P)
  387.   (move .l (d@r P -2) TP)
  388.   (jmp (@r TP))
  389.   
  390. %undefined-effect    ; a1 is string
  391.   (move .l TP A2)              ; template
  392.   (move .l (d@nil slink/kernel) P)
  393.   (move .l (d@static P (static 'handle-undefined-effect)) P)
  394.   (move .l (d@r P -2) TP)
  395.   (jmp (@r TP))
  396.   
  397.  
  398.  
  399. ))                                     
  400.  
  401. (lap-template (0 0 -1 t stack %int-return-handler)
  402. %int-return
  403.     (bset ($ 6) (d@r task task/critical-count))
  404.     (move .l (d@r SP 12) (d@r SP (* (+ *pointer-temps* *scratch-temps* 19) 4)))
  405.     (add .w ($ 20) sp)        ; pop template,header,pointers on stack,hack top,pc
  406.     (movem .l (@r+ SP) '(a0 a1 a2 a3 a4 a5))
  407.     (move .l ($ -8) S0)
  408. %int-return-restore-loop                                  ; restore temps
  409.     (move .l (@r+ SP) (index (@r TASK) S0))
  410.     (add .l ($ 4) S0)
  411.     (cmp .l ($ temp-block-size) S0)          
  412.     (j< %int-return-restore-loop)
  413.     (movem .l (@r+ SP) '(d0 d1 d2 d3 d4 d5))
  414.     (bclr ($ 6) (d@r task task/critical-count))
  415.     (rts)
  416. %int-return-handler
  417.     (move .l nil-reg an)
  418.     (rts))
  419.  
  420.  
  421.  
  422.  
  423. (define (clear-extra-registers)
  424.   (lap ()
  425.     (move .l ($ -4) S0)
  426. zero-loop                                  ; restore temps
  427.     (clr .l (index (@r TASK) S0))
  428.     (add .l ($ 4) S0)
  429.     (cmp .l ($ temp-block-size) S0)
  430.     (j< zero-loop)
  431.     (move .l ($ -2) NARGS)
  432.     (move .l (@r sp) tp)
  433.     (jmp (@r tp))))
  434.     
  435.  
  436. (lap-template (0 0 -1 t stack pc-check-return-handler) 
  437. pc-check-return
  438.     (add .l ($ 4) SP)                            ; pop return address
  439.     (move .l A1 (@-r SP))                        ; code vector of pc
  440.     (pea (d@r A1 -2))                            ; fixnumized code vector
  441.     (pea (label gc-template))
  442.     (move .l (d@nil slink/kernel) P)
  443.     (move .l (d@static P (static 'really-gc)) P)
  444.     (move .l (d@r P -2) TP)
  445.     (jmp (@r TP))
  446. pc-check-return-handler
  447.   (move .l nil-reg AN)
  448.   (rts))
  449.  
  450.                  
  451. ;;; sizes of gc template:
  452. ;;; pointer -- n registers + n temps + 1 extra + 2 code vector + tp
  453. ;;; scratch -- gc return address + 1 other + n registers + n temps
  454.  
  455. (lap-template ((+ *pointer-temps* *pointer-registers* 4) 
  456.                (+ *scratch-temps* *scratch-registers* 2) 
  457.                -1 t stack gc-template-handler)       ;; see gc.t
  458. gc-template               
  459.   (lea (label %post-gc-nary-setup) P)
  460.   (move .l P (d@nil slink/nary-setup))
  461.   (add .w ($ 4) SP)                                  ; pop template 
  462.   (move .l (@r+ SP) S0)                              ; pop old code (fixnum)
  463.   (move .l (@r+ SP) S1)                              ; pop relocated code
  464.   (cmp .l S1 nil-reg)
  465.   (j= gc-continue)                                   ; not relocated
  466.   (sub .l ($ 2) S1)                                  ; fixnumize new code
  467.   (move .l (d@r SP (* (+ *no-of-registers* 3) 4)) S2); get old pc
  468.   (sub .l S0 S2)                                     ; offset
  469.   (add .l S2 S1)                                     ; new pc
  470.   (move .l S1 (d@r SP (* (+ *no-of-registers* 3) 4))); update pc
  471. gc-continue
  472.   (movem .l (@r+ SP) '(a0 a1 a2 a3 a4 a5))
  473.   (move .l ($ -4) S0)
  474. restore-loop                                  ; restore temps
  475.   (move .l (@r+ SP) (index (@r TASK) S0))
  476.   (add .l ($ 4) S0)
  477.   (cmp .l ($ temp-block-size) S0)
  478.   (j< restore-loop)
  479.   (movem .l (@r+ SP) '(d0 d1 d2 d3 d4 d5))
  480.   (rts)
  481. gc-template-handler
  482.   (move .l nil-reg AN)
  483.   (rts))
  484.                           
  485.                                                             
  486. (lap-template (0 0 0 nil stack stack-base-handler)
  487. stack-base-template
  488.   (jmp (*d@nil slink/undefined-effect))
  489. stack-base-handler
  490.   (move .l (d@nil slink/kernel) AN)
  491.   (move .l (d@static AN (static 'handle-stack-base)) A1)
  492.   (jmp (*d@nil slink/dispatch-label)))
  493.  
  494.  
  495. (define (lap-relocate frame old-tp new-tp offset)
  496.   (lap ()                 
  497.     (move .l (d@r TASK 12) S0)           ; offset
  498.     (move .l (index (d@r A1 2) S0) S1)   ; code
  499.     (sub .l A2 S1)                       ; code-offset
  500.     (add .l S1 A3)                       ; new code
  501.     (move .l A3 (index (d@r A1 2) S0))
  502.     (move .l ($ -1) NARGS)
  503.     (move .l (@r sp) tp)
  504.     (jmp (@r tp))))
  505.  
  506.     
  507.  
  508. (define (current-task)
  509.  (lap ()
  510.   (move .l TASK A1)
  511.   (add .l ($ (fx+ %%task-header-offset 2)) A1)   ; offset is negative !
  512.   (move .l ($ -2) nargs)
  513.   (move .l (@r sp) tp)
  514.   (jmp (@r tp))))
  515.  
  516.   
  517. (define-foreign gc_interrupt (gc_interrupt) ignore)
  518.  
  519. ;;; Hack for getting into the debugger.
  520.  
  521. (define (@@ address)    ; randomness
  522.   (lap ()
  523.     (add .l ($ 2) a1)
  524.     (move .l ($ -2) nargs)
  525.     (move .l (@r sp) tp)
  526.     (jmp (@r tp))))
  527.  
  528.  
  529. (define (bpt . args)
  530.     (lap ()
  531.         (trap (number 9))
  532.         (move .l ($ 0) s0)
  533.         (move .l s0 a1)
  534.         (move .l ($ -2) NARGS)
  535.     (move .l (@r sp) tp)
  536.     (jmp (@r tp))))
  537.  
  538. (define (crawl-exhibit-fault-frame frame)
  539.   (cond ((not (foreign-fault-frame? frame))       ; foreign
  540.          (print-register frame 'p 3)
  541.          (print-register frame 'a1 4)
  542.          (print-register frame 'a2 5)
  543.          (print-register frame 'a3 6)
  544.          (print-register frame 'an 7)
  545.          (print-register frame 'tp 8))
  546.         (else
  547.          (format t " In foreign code; no information available~%"))))
  548.  
  549. (define (trace-fault-frame frame)
  550.   (cond ((alt-bit-set? frame)          
  551.          (move-object (make-pointer frame 0)))           ; foreign cont
  552.         (else
  553.          (let ((tp (extend-elt frame 8)))                ; old TP
  554.            (trace-pointers (make-pointer frame 2) 6)     ; trace registers
  555.            (trace-pointers (make-pointer frame 9)        ; trace temps
  556.                            (fx+ *pointer-temps* 1))
  557.            (let ((ptrs (extend-elt frame 0))             ; trace top of stack
  558.                  (size (fault-frame-slots frame)))
  559.              (trace-pointers (make-pointer frame (fx- size 1)) ptrs))
  560.            (if (eq? (extend-elt frame 1) 0)              ; hack-top-of-stack?
  561.                (relocate-random-code frame 2 tp)         ; relocate PC
  562.                (relocate-random-code frame 1 tp))))))    ; relocate top-of-stack
  563.  
  564. (define (relocate-random-code frame offset old-tp)
  565.   (if (in-old-space? (extend-elt frame offset))
  566.       (lap-relocate frame old-tp (extend-elt frame 8) offset)))
  567.  
  568. (define (make-link-snapper value unit i)
  569.   (lap ()
  570.     (move .l (d@nil slink/snapper-freelist) p)
  571.     (cmp .l p nil-reg)
  572.     (j= cons-snapper-1)
  573.     (move .l (d@r p 1) an)
  574.     (move .l (d@r p -3) (d@nil slink/snapper-freelist))
  575.     (move .l (d@nil slink/pair-freelist) (d@r p -3))
  576.     (move .l p (d@nil slink/pair-freelist))
  577. foobarfoo
  578.     (move .l a1 (d@r an 2))
  579.     (move .l a2 (d@r an 6))
  580.     (move .l a3 (d@r an 10))
  581.     (move .l an a1)
  582.     (move .l ($ -2) nargs)
  583.     (move .l (@r sp) tp)
  584.     (jmp (@r tp))
  585. cons-snapper-1    
  586.     (lea (label link-snapper) an)
  587.     (move .l ($ 12) s1)
  588.     (jsr (label %make-extend))
  589.     (jbr foobarfoo)))
  590.  
  591. (define *link-snapper-template*
  592. (lap-template (3 0 1 t heap handle-snapper)
  593. link-snapper
  594.   (move .l p an)
  595.   (move .l (d@r p 2) p)
  596.   (move .w P S0)
  597.   (and .b ($ 3) S0)
  598.   (cmp .b ($ tag/extend) S0)                     ; check proc is extend
  599.   (jn= %icall-bad-proc)
  600.   (move .l (d@r P -2) TP)                         ; fetch template
  601.   (move .w TP S0)
  602.   (and .b ($ 3) S0)                 ; check proc is extend
  603.   (cmp .b ($ tag/extend) S0)
  604.   (jn= %icall-bad-proc)
  605.   (move .l  (d@r TP -2) S0)       ; check template is valid (high bit set)
  606.   (j>= %icall-bad-proc)
  607.   (cmp .b (d@r TP template/nargs) NARGS)         ; check number of args
  608.   (j= snap-link)
  609.   (j< %icall-wrong-nargs)
  610.   (btst ($ 30) S0)                            ; check nary bit
  611.   (j= %icall-wrong-nargs)
  612. snap-link
  613.   (move .l an (d@r task task/extra-pointer))
  614.   (move .l (d@r an 10) s0)
  615.   (move .l (d@r an 6) an)
  616.   (move .l p (index (d@r an 2) s0))
  617.   (move .l (d@nil slink/pair-freelist) an)
  618.   (cmp .l an nil-reg)
  619.   (j= cons-pair)
  620.   (move .l (d@r an -3) (d@nil slink/pair-freelist))
  621. consed-pair
  622.   (move .l (d@r task task/extra-pointer) (d@r an 1))
  623.   (move .l (d@nil slink/snapper-freelist) (d@r an -3))
  624.   (move .l an (d@nil slink/snapper-freelist))
  625.   (jmp (@r TP))
  626. cons-pair
  627.   (jsr (label %make-pair))
  628.   (jbr consed-pair)
  629. handle-snapper
  630.   (move .l nil-reg AN)
  631.   (rts)))
  632.